home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / elflib.zip / DEMO.LSP < prev    next >
Text File  |  1992-12-01  |  18KB  |  499 lines
  1. ;;; DEMO.LSP
  2. ;;; Copyright 1992 by Mountain Software
  3. ;;;
  4. ;;; This program requires ELF, the Extended Lisp Function library
  5. ;;;
  6. ;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
  7. ;;; WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
  8. ;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
  9. ;;;
  10. ;;;*===================================================================*
  11. ;;;
  12. ;;; Demo.Lsp is a demonstration of the capabilities of the ELF
  13. ;;; library. Demo exercises many (but not all) ELF functions and
  14. ;;; commands and illustrates how the functions can be utilized.
  15. ;;; It also provides AutoLISP programmers with sample code that
  16. ;;; can included in their own programs.
  17.  
  18. (Princ "\nLoading Demo.Lsp")
  19. (Load"ELF")
  20.  
  21. ;;;*----- The ELF Demo
  22.  
  23. (DeFun C:DEMO( / mstr mfun i attr done video vcols vrows ans key helplst)
  24.   (SetQ mstr   '("Introduction" "Window System" "Video Functions"
  25.                  "Data Entry Form" "String Functions" "Math Functions"
  26.                  "Directory Demo" "File Functions" "Low Level Functions"
  27.                  "Look at an ASCII file" "Function List" "ELF Apps" "Quit")
  28.     mfun   '(intro wdemo scrdemo edemo strdemo mdemo ddemo
  29.                  fdemo ldemo look_demo (list () '(Set_Color 23) '(c:elf))
  30.                  apps_demo (list () '(SetQ done T)))
  31.         bcolor (| white lgrey_bg)
  32.         logo    "▒▒▒▒░▒░░░░▒▒▒▒\n▒░░░░▒░░░░▒░░░\n▒▒▒▒░▒░░░░▒▒▒▒\n▒░░░░▒░░░░▒░░░\n▒▒▒▒░▒▒▒▒░▒░░░"
  33.         old_error *error*
  34.         *error*   DemoError
  35.         helplst (list "[ ELF Demo Help ]" ""
  36.                       "Select one of the Menu Items or press <Esc> to Quit" ""
  37.                       "This is a Demonstration of ELF"
  38.                       "The Extended Lisp Function Library" ""
  39.                       "ELF is available from:" ""
  40.                       (eval name) (eval address)
  41.                       (strcat city ", " state " " zip) ""
  42.                       "Press <F1> for Menu help")
  43.   )
  44.   (TextScr)
  45.   (SetQ attr (| lgrey blue_bg)
  46.         video (Get_Video) vcols (Car video) vrows (Cadr video))
  47.   (Set_Color attr)
  48.   (Scr_Fill 0 1 vcols (- vrows 2) 176 bcolor)
  49.   (GotoXY 0 1)
  50.   (Puts logo bcolor)
  51.   (Scr_Fill 0 0 vcols 1 32 attr)
  52.   (Prts 19 0 "Extended Lisp Function [ELF] library Demo" (| white blue_bg))
  53.   (Scr_Fill 0 (1- vrows) vcols 1 32 attr)
  54.   (Prts 26 (1- vrows) "(c) 1992 Mountain Software" attr)
  55.   (bloop)
  56.   (While (Not done) (Progn
  57.     (Set_menu_help helplst)
  58.     (Wopen -1 -1 27 18 (| white cyan_bg) (| cyan cyan_bg) (| no_bd shadow_bd))
  59.     (Wputcen "ELF Demo Menu")
  60.     (WgotoXY 0 1)
  61.     (Wputcen "Select" (| lcyan cyan_bg))
  62.     (SetQ ans (Wmenu mstr -1 6 (| white cyan_bg) (| black cyan_bg)
  63.                      (| white black_bg) (| single_bd tlhl_bd))
  64.           key (Cadr ans)
  65.           i   (Car ans))
  66.     (Wclose)
  67.     (Save_Screen)
  68.     (If(= key Esc_Key)
  69.       (SetQ done T)
  70.     ;else
  71.       (Eval(List(nth i mfun)))         ;Execute the selected function
  72.     )
  73.     (Restore_Screen)
  74.   ))
  75.   (WcloseAll)
  76.   (SetQ *error* old_error)
  77.   (Cls 7)
  78. )
  79.  
  80. ;;;*----- Introduction
  81.  
  82. (DeFun INTRO()
  83.   (Wmenu '("ELF is a library of over 150 new functions for"
  84.            "AutoLISP.  In addition, ELF also adds 14 file"
  85.            "management and utility commands to AutoCAD. The"
  86.            "library and commands are contained in a single"
  87.            "EXP file, and expands AutoLISP into a \"rich\""
  88.            "programming language. The range of functions"
  89.            "include video and text window extentions, math"
  90.            "and string handling, file and directory, list"
  91.            "handling, keyboard, sound, and utility routines."
  92.            "During this demonstration you may press <F1> for"
  93.            "online help and <Esc> to exit or quit.")
  94.            -1 -1 23 31 31 (| 5 32))
  95. )
  96.  
  97. ;;;*----- ELF Apps
  98.  
  99. (DeFun APPS_DEMO( / mstr flst rslt fname key i)
  100.   (Setq mstr '("ELF Notepad - an ASCII editor in AutoLISP"
  101.                "eTables     - view Block, Layer, etc tables"
  102.                "Template    - a generic ELF application")
  103.         flst '("notepad" "etables" "template")
  104.         rslt (Wmenu mstr))
  105.   (Cls 7)
  106.   (If(/= (Cadr rslt) Esc_Key)
  107.     (run (Nth (Car rslt) flst)))
  108. )
  109.  
  110. ;;;*----- Load and run an AutoLISP file
  111.  
  112. (Defun RUN(funcname / func filename)
  113.   (SetQ func     (Read(Strcat "C:" funcname))
  114.         filename (Strcat funcname ".LSP"))
  115.  
  116. ;*-----Load the function if not already loaded
  117.  
  118.   (If(Not(Cadr(Eval Func)))
  119.     (If(Findfile filename)
  120.       (Load funcname)
  121.    ;else
  122.       (Wmsg(Strcat "\nError: " filename "\nis not on the AutoCAD library path."))
  123.     )
  124.   )
  125.  
  126. ;*----- Execute the function if it exists
  127.  
  128.   (if(= (Type (Eval func)) 'LIST)
  129.     (Eval(list func))
  130.   ;else
  131.     (Wmsg(Strcat "\nError: " funcname "\nis not a valid AutoLISP function"))
  132.   )
  133.   (princ)
  134. )
  135.  
  136. (SetQ contact "Jerry Workman"
  137.       name    "Mountain Software"
  138.       address "1579 Nottingham Road"
  139.       city    "Charleston"
  140.       state   "WV"
  141.       zip     "25304-2453"
  142. )
  143.  
  144. ;;;*-----Data Entry Demo
  145.  
  146. (DeFun EDEMO( / fields tcolor dcolor)
  147.   (SetQ tcolor (| dgrey lgrey_bg)
  148.         dcolor (| white lgrey_bg)
  149.         wcolor (| black lgrey_bg))
  150.  
  151. ;;;*=========================================================*
  152. ;;;*              Data Entry Form Layout                     *
  153. ;;;*=============col=row=prompt=========col=row=symbol==width*
  154.   (SetQ fields '((1  1   "Contact"       15 1   contact 40)
  155.                  (1  3   "Company Name"  15 3   name    40)
  156.                  (1  5   "Address"       15 5   address 40)
  157.                  (1  7   "City"          15 7   city    15)
  158.                  (33 7   "State"         40 7   state    2)
  159.                  (43 7   "ZIP"           47 7   zip     10)))
  160.  
  161.   (Wopen 0 0 vcols vrows 7 7 0)         ;open a window to cover the screen
  162.   (Wpopup 68 15 dcolor dcolor 0)        ;and another for the background
  163.   (Wtitle "Data entry form" 1 wcolor)
  164.   (Wtitle "<Ctrl><Enter> - done" 3 wcolor)
  165.   (Wtitle "<F1> - help" 5 wcolor)
  166.   (Wpopup 64 13 wcolor wcolor 10)       ;two more nested windows to make the
  167.   (Wpopup 60 11 wcolor wcolor 18)       ;raised border effect
  168.   (getdata fields tcolor dcolor)        ;process the form
  169.   (WcloseAll)
  170. )
  171.  
  172. ;;;*----- Process the Data Entry form
  173.  
  174. (DeFun GETDATA(template pcolor dcolor / done fld i key rslt &symbol)
  175.   (SetQ cnt (Length template) i 0)
  176.   (Repeat cnt                          ;;; display form
  177.     (SetQ fld   (Nth i template)
  178.           i     (1+ i))
  179.     (Wprts (Car fld) (Cadr fld) (Caddr fld) pcolor)
  180.     (Wprts (Nth 3 fld) (Nth 4 fld) (Eval(Nth 5 fld)) dcolor)
  181.   )
  182.   (SetQ i 0 done nil)
  183.   (While (Not done) (Progn
  184.     (SetQ fld     (Nth i template)
  185.           rslt    (getitem fld dcolor)
  186.           &symbol (Nth 5 fld)               ;;; pointer to variable
  187.           key     (Cadr rslt)
  188.     )
  189.     (Set  &symbol (Car rslt))               ;;; assign string to variable
  190.   (Cond
  191.     ((= key Esc_Key)   (SetQ done T))       ;;; escape pressed, quit
  192.     ((= key C_Ent_Key) (SetQ done T))       ;;; <Ctrl>Enter
  193.     ((= key Up_Key)    (SetQ i (up1 cnt)))  ;;; up arrow
  194.     (T (SetQ i (Rem (1+ i) cnt))))
  195.   ))
  196. )
  197.  
  198. ;;;*----- Move back one field
  199.  
  200. (DeFun UP1(cnt)                         ;;; guarantees no negative values
  201.   (Rem (1- (+ cnt i)) cnt)
  202. )
  203.  
  204. ;;;*----- Fetch the String
  205.  
  206. (DeFun GETITEM(fld dcolor)
  207.     (WgotoXY (Nth 3 fld) (Nth 4 fld))
  208.     (StrGet (Eval (Nth 5 fld)) (Nth 6 fld) 0 "▒" dcolor)
  209. )
  210.  
  211. ;;;*----- Screen Demo
  212.  
  213. (DeFun SCRDEMO()
  214.   (Scr_Fill 0 0 vcols vrows 178 (| blue lgrey_bg))
  215.   (Wmsg (StrCat "(Scr_Fill) fills areas of the screen,"
  216.                 "\n(Save_Screen) takes a snapshot of the screen,"
  217.                 "\n(Restore_Screen) restores the snapshot,"
  218.                 "\nand (CLS) clears the screen. We will cycle"
  219.         "\n100 screen redraws now.") 1 (| white brown_bg))
  220.   (Repeat 100
  221.     (Restore_Screen)
  222.     (Save_Screen)
  223.     (CLS 7)
  224.   )
  225.   (Repeat 1000
  226.     (Prts (Fix(Rem (Rand) (- vcols 15))) (Fix(Rem (Rand) (1- vrows))) "Hello World" (Fix(Rem (Rand) 90)))
  227.   )
  228.   (Wmsg "1000 Strings using (Prts)\n(The hiccup was from AutoLISP)" 1 (| white red_bg) (| black red_bg))
  229. )
  230.  
  231. ;;;*----- Directory Demo
  232.  
  233. (DeFun DDEMO( / dstat drive_no drive_str sector cluster
  234.                 drive_bytes free_bytes)
  235.   (SetQ   dstat       (GetDiskFree 0)
  236.           drive_no    (GetDisk)
  237.           drive_str   (Chr(+ drive_no (1-(ASCII "A"))))
  238.           sector      (Cadddr dstat)
  239.           cluster     (* sector (Caddr dstat))
  240.           drive_bytes (* cluster (Car dstat))
  241.           free_bytes  (* cluster (Cadr dstat))
  242.   )
  243.   (Wopen 0 0 vcols vrows attr attr 4)
  244.   (Wtitle "Directory" 1)
  245.   (Wprintf "\n(GetDir) returns\n\t%s" (GetDir))
  246.   (Wprintf "\n(GetDisk) returns\n\t%d or drive %s:" drive_no drive_str)
  247.   (Wprintf "\n\n(GetDiskFree 0) returns:\n\t(%.0f %.0f %d %d)"
  248.                 drive_bytes free_bytes sector cluster)
  249.   (Wprintf "\nThe current drive has the following stats:")
  250.   (Wprintf "\n\tsector size: %d, cluster size: %d " sector cluster)
  251.   (Wprintf "\n\tTotal bytes: %.0f, Free bytes: %.0f " drive_bytes free_bytes)
  252.   (wpause)
  253.   (Wopen 2 7 40 8 32 32 (| 1 8))
  254.   (Wputs "\n (WgetFile) Gets a filename...")
  255.   (Wputs "\n\n  Press <AltD> to Select\n  another Disk Drive")
  256.   (Wmsg (WgetFile "*.*" 33 50 -1 (| white cyan_bg)))
  257.   (Wclose)
  258. )
  259.  
  260. ;;;*----- File system Demo
  261.  
  262. (DeFun FDEMO( / filename fl)
  263.   (SetQ filename    (FindFile "ACAD.PGP")
  264.         fl          (SplitPath filename)
  265.   )
  266.   (Wopen 0 0 vcols vrows attr attr 3)
  267.   (Wtitle "File Demo" 1)
  268.   (Wprintf "\n\n(CopyFile \"C:\\CONFIG.SYS\" \".\")")
  269.     (CopyFile "C:\\CONFIG.SYS" ".")
  270.   (Wprintf "\n(MkDir \"&TEMP&\")")
  271.     (MkDir "&TEMP&")
  272.   (Wprintf "\n(MoveFile \"CONFIG.SYS\" \"&TEMP&\")")
  273.     (MoveFile "CONFIG.SYS" "&TEMP&")
  274.   (Wprintf "\n\n(FullPath \"&TEMP&\\CONFIG.SYS\") returns\n%s"
  275.     (FullPath "&TEMP&\\CONFIG.SYS"))
  276.   (Wprintf "\n\n(EraseFile \"&TEMP&\\CONFIG.SYS\")")
  277.     (EraseFile "&TEMP&\\CONFIG.SYS")
  278.   (Wprintf "\n(RmDir \"&TEMP&\")")
  279.     (RmDir "&TEMP&")
  280.   (wpause)
  281.   (Wprintf "\n\n(SplitPath %s) returns\n\t" filename)
  282.   (Wprintf "\nDrive:     \"%s\"" (Car fl))
  283.   (Wprintf "\nDirectory: \"%s\"" (Cadr fl))
  284.   (Wprintf "\nName:      \"%s\"" (Caddr fl))
  285.   (Wprintf "\nExt:       \"%s\"" (Cadddr fl))
  286.   (wpause)
  287.   (Wclose)
  288. )
  289.  
  290. (DeFun BLOOP()
  291.   (Beep 1600 0.1)
  292.   (Beep 800 0.1)
  293.   (Beep 1600 0.1)
  294. )
  295.  
  296. ;;;*----- Play Charge
  297.  
  298. (DeFun CHARGE( / c f a c2)
  299.   (SetQ c 262 f 349 a 440 c2 523)
  300.   (Beep c 0.1)
  301.   (Beep f 0.1)
  302.   (Beep a 0.1)
  303.   (Beep c2 0.2)
  304.   (Beep a 0.1)
  305.   (Beep c2 0.3)
  306. )
  307.  
  308. ;;;*----- Low Level Function Demo
  309.  
  310. (DeFun LDEMO()
  311.   (Wopen 0 0 vcols vrows attr attr 3)
  312.   (Wtitle "Low Level Functions" 1)
  313.   (Wprintf "\nbeeping the speaker...") (Beep) (Wait 0.5)
  314.   (Wprintf "\nand custom sounds...\n") (charge)
  315.   (Wprintf "\nThe current time is:\n\t%s on %s\n" (StrTime) (StrDate))
  316.   (Wprintf "\nPress any letter key to test (GetKey)...")  (SetQ key (GetKey))
  317.   (Wprintf "(GetKey) returns \%d\) or \"%s\"" key (Chr(LoByte key)))
  318.   (Wprintf "\n\n(Key_Ready) returns immediately with any waiting keystroke")
  319.   (Wprintf "\n(KbHit) checks for a waiting keystroke")
  320.   (Wprintf "\n\teg (While(Not(KbHit)) (long_loop_process))")
  321.   (Wprintf "\n\n(Key_Stuff) inserts keystrokes in the keyboard buffer")
  322.   (Wprintf "\n(Key_Clear) removes any pending keystrokes")
  323.   (Wprintf "\n(Key_Stat) returns the status of control keys (Ctrl/Alt/Shift)")
  324.   (wpause)
  325.   (Wclose)
  326. )
  327.  
  328. ;;;*----- Math Demo
  329.  
  330. (DeFun MDEMO( / radians val1 val2)
  331.   (SetQ val1 123.456 val2 0.5)
  332.   (Wopen 0 0 vcols vrows attr attr 5)
  333.   (Wtitle "Math Functions" 1)
  334.   (SRand)
  335.   (Wprintf "\n\nrandom numbers:\n") (Repeat 5 (Wprintf "%.0f " (Rand)))
  336.   (Wprintf "\n\nDegrees to Radians conversion:\n\t%f degrees is %f radians"
  337.           val1 (SetQ radians (DtR val1)))
  338.   (Wprintf "\nRadians to Degrees conversion:\n\t%f radians is %f degrees"
  339.           radians (RtD radians))
  340.   (Wprintf "\nTrig Functions:")
  341.   (Wprintf "\n\t(Tan  %f) returns %f" val2 (Tan radians))
  342.   (Wprintf "\n\t(Acos %f) returns %f" val2 (Acos val2))
  343.   (Wprintf "\n\t(Asin %f) returns %f" val2 (Asin val2))
  344.   (Wprintf "\n\t(SinH %f) returns %f" val2 (SinH val2))
  345.   (Wprintf "\nAnd...")
  346.   (Wprintf "\n\t(Round %f 1) returns %f" radians (Round radians 1))
  347.   (Wprintf "\n\t(Floor %f) returns %f" radians (Floor radians))
  348.   (Wprintf "\n\t(Ceil  %f) returns %f" radians (Ceil radians))
  349.   (Wpause)
  350.   (Wclose)
  351. )
  352.  
  353. ;;;*----- String Demo
  354.  
  355. (DeFun STRDEMO( / str1 str2 str3 str4 ulist slist fmt real1 int1)
  356.   (SetQ str1        "AAA;BBB;CCC"
  357.         str2        "    Hello    World    "
  358.         str3        "Th;is: is /a; test"
  359.         str4        ";:/"
  360.         ulist       '("ZZZ" "SSS" "AAA")
  361.         slist       (Qsort ulist)
  362.         fmt         "%8.3g %4Xh"
  363.         pos         2
  364.         real1       1.23456
  365.         int1        4321
  366.   )
  367.   (Wopen 0 0 vcols vrows attr attr 3)
  368.   (Wtitle "String / List Demo" 1)
  369.   (Wprintf "\n\n(Sprintf \"%s\" %f %d) returns\n\t\"%s\"" fmt real1 int1 (Sprintf fmt real1 int1))
  370.   (Wprintf "\n\n(StrDela \"%s\" \"%s\") returns\n\t\"%s\"" str3 str4 (StrDela str3 str4))
  371.   (Wprintf "\n(StrTrimL \"%s\") returns\n\t\"%s\"" str2 (StrTrimL str2))
  372.   (Wprintf "\n(StrTrimR \"%s\") returns\n\t\"%s\"" str2 (StrTrimR str2))
  373.   (Wprintf "\n(StrTrim \"%s\") returns\n\t\"%s\"" str2 (StrTrim  str2))
  374.   (Wprintf "\n(StrRev \"%s\") returns\n\t\"%s\"" str1 (StrRev str1))
  375.   (Wprintf "\n(Field \"%s\" \";\" 2) returns\n\t\"%s\"" str1 (Field str1 ";" 2))
  376.   (Wprintf "\n(Qsort \'\(\"%s\" \"%s\" \"%s\"\)) returns\n\t\(\"%s\" \"%s\" \"%s\"\)" (Car ulist)(Cadr ulist)(Caddr ulist)
  377.         (Car slist)(Cadr slist)(Caddr slist))
  378.   (Wprintf "\n(Insert \'\(\(\"%s\" \"%s\" \"%s\"\) %d \"%s\"\)) returns\n\t\(\"%s\" \"%s\" \"%s\" \"%s\"\)"
  379.         (Car ulist)(Cadr ulist)(Caddr ulist) pos str1
  380.         (Car (setq slist (Insert slist pos str1)))(Cadr slist)(Caddr slist)(nth 3 slist))
  381.   (Wpause)
  382.   (Wclose)
  383. )
  384.  
  385. ;;;*----- Window Demo
  386.  
  387. (DeFun WDEMO( / str edit_help cols rows)
  388.   (Scr_Fill 0 0 vcols vrows 178 (| lgrey blue_bg))
  389.   (Set_Color (SetQ attr (| white blue_bg)))
  390.   (Setq cols 4 rows 4)
  391.   (Set_Cursor 32 0)                     ; cursor off
  392.   (While (Or(< cols Vcols)(< rows Vrows)) (progn
  393.     (Setq cols (Min(+ cols 4) Vcols) rows (Min(+ rows 2) Vrows))
  394.     (Wpopup cols rows attr attr 1)
  395.   ))
  396.   (Wopen 2 2 35 6 (| black cyan_bg) (| yellow cyan_bg) hdouble_bd)
  397.   (Wtitle "Hidden Window")
  398.   (Wgotoxy 0 3) (Wputcen "This was is hidden")
  399.   (Wopen 4 4 35 8 (| dgrey lgrey_bg) (| black lgrey_bg) no_bd)
  400.   (Wtitle "Multiple Overlapping Windows")
  401.   (Wputcen "with cursor positioning," (| blue lgrey_bg))
  402.   (Wait 0.5)  (WgotoXY 0 2)
  403.   (Wputcen "window write functions," (| red lgrey_bg))
  404.   (WgotoXY 0 4)
  405.   (Wputcen "full color, shadows and" (| black lgrey_bg))
  406.   (WgotoXY 0 5)
  407.   (Wputcen "cursor control" (| black lgrey_bg))
  408.   (Wait 0.5) (Set_Cursor 12 13)            ; cursor on
  409.   (Wshadow)  (Waiting)    (Wclose)
  410.   (Wopen 2 16 40 7 (| white brown_bg) (| yellow brown_bg) vdouble_bd)
  411.   (Wtitle "[ Editor ]" 1)
  412.   (Wtitle "[ F1 - Help ]" 3) (Wshadow)
  413.   (Wputcen "Using (getstr) to get input:")
  414.   (Wputs "\n\nEdit this string: " (| yellow brown_bg))
  415.   (Set_Edit_Help
  416.     '("(StrGet) Function" ""
  417.       "This is user defined help for the line editor (StrGet)" ""
  418.       "It is defined by the function \"(Set_Edit_Help)\" and"
  419.       "the symbol \"edit_help\" in release 12 and higher."))
  420.   (SetQ str (Car(StrGet "ELF demo" 20 0 "▒" (| black lgrey_bg))))
  421.   (Wputs "\nYou entered: ") (Wputs str (| black red_bg))
  422.   (SetQ str "Mountain Software"
  423.     str (WgetStr "using (WgetStr)" str 40 (| yellow black_bg)(| white black_bg)))
  424.   (Wmsg (StrCat "Wmsg Displays a Message\nYou entered " str) 1 (| black lgrey_bg))
  425.   (WcloseAll)
  426.   (Wmsg (StrCat "The Window System contains\nfunctions for text window"
  427.                 "\nhandling, menus, screen painting\n"
  428.         "with complete color and cursor\ncontrol") 1 (| white red_bg))
  429.   (Set_Color (SetQ attr (| lgrey blue_bg)))
  430.   (Wcloseall)
  431. )
  432.  
  433. (DeFun WAITING()
  434.   (Wtitle "Delaying 2 second..." 4 (| blink white red_bg))
  435.   (Wait 2.0)
  436. )
  437.  
  438. (DeFun LOOK_DEMO( / key dat i col)
  439.   (Wopen 0 0 vcols vrows 48 48 0)
  440.   (Set_Color 23)                        ;;; look will use this color
  441.   (Wopen 2 -1 19 5 23 23 5)
  442.   (Wputs "\n Select a file")
  443.   (While (SetQ fn (WgetFile))
  444.     (If fn (Progn
  445.       (Save_Screen)
  446.       (Look fn)
  447.       (Restore_Screen)
  448.     ))
  449.   )
  450.   (Wclose)
  451.   (Wclose)
  452. )
  453.  
  454. (DeFun WPAUSE()
  455.   (Wputs "\n\npress any key...")
  456.   (GetKey)
  457. )
  458.  
  459. (DeFun C:TIMETEST( / a)
  460.   (timeit '(List () (Line '(0.0 0.0) '(1.0 1.0))) 1000)
  461.   (Pause)
  462.   (timeit '(List () (Command "line" "0,0" "1,1" "")) 1000)
  463. )
  464.  
  465. (DeFun TIMEIT(func times / start stop)
  466.   (printf "\n\nTiming %d executions of function " times) (Princ func)
  467.   (printf "\nClock start at %.2f (%s)" (SetQ start (Clock)) (StrTime))
  468.   (Repeat times (Eval func))
  469.   (SetQ stop (Clock))
  470.   (printf "\n%s" func)
  471.   (printf " finished...\nClock stop at %.2f, elapsed time is %.2f seconds"
  472.      stop (SetQ seconds (Abs(- stop start))))
  473.   (printf "\nor %f seconds per iteration" (/ seconds times))
  474.   (Princ)
  475. )
  476.  
  477. (DeFun C:TOP10( / t10 ans key)
  478.   (SetQ t10 '("ZOOM W" "ZOOM P" "LINE" "ARC" "CIRCLE"
  479.               "ERASE" "PLINE" "PEDIT" "TRIM" "BREAK"))
  480.   (SetQ ans (Wmenu t10 -1 -1 (| white red_bg)))
  481.    (If(/= (Cadr ans) Esc_Key)
  482.      (Key_Stuff (StrCat(Nth (Car ans) t10)"\n")))
  483. )
  484.  
  485. (DeFun DemoError(s)
  486.   (Beep)
  487.   (Wmsg (Strcat "Demo ERROR\n" s) 1 (| white red_bg))
  488.   (WcloseAll)
  489.   (Cls 7)
  490.   (SetQ *error* old_error old_error nil)
  491.   (Princ)
  492. )
  493.  
  494. (Princ "\nDEMO.LSP loaded, enter \"DEMO\" to run...")
  495. (Princ)
  496.  
  497. ;;;*----- End of Demo.Lsp
  498.  
  499.